 
C type PFPU = record
C               NAME: integer; (* index into NAMTXT *)
C               NARGS: integer;
C               ARGS: ^(heap) HEAD (PFPUARG); (* 0 = nil *)
C               COMMONS: ^(heap) HEAD (PFPUCU); (* 0 for ENTRY points *)
C               PARENTS: ^(heap) HEAD (PARENT); (* ditto *)
C               DESC: ^(heap) HEAD (PFPUDESC);  (* ditto *)
C               DTYPE: integer;
C               CHRLEN: integer;
C               ACTUAL: ^PFPU         (* 0 except for ENTRY points *)
C             end;
 
C type PFEX = record
C               NAME: integer;
C               DTYPE: integer;
C               CHRLEN: integer;
C               NARGS: integer;
C               ARGS: ^(heap) HEAD(PFEXARG);
C               INDARG: ^PFPUARG    (* only for indirect refs *)
C             end;
 
C type PFPUARG = record
C                   DTYPE: integer;
C                   CHLEN: integer;
C                   case STRUC of
C                       var,array: (USAGE: (arg,read,update));
C                       proc: (REF: integer (EXNODE index))
C                       end;
C                   STRUC: (var,array,proc);
C                   SIZE: integer;
C                   DESC: ^(heap) HEAD (PUARGDES);
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   PRNTS: ^(heap) HEAD (LATPAR)
C                end;
 
C type PFEXARG = record
C                   DTYPE: integer;
C                   ATYPE: integer;
C                   PROCS: ^(heap) HEAD (PFPROC);
C                   if (DTYPE=type_char) then
C                       CHMIN,CHMAX: integer
C                   end if
C                 end;
 
C type PFPUDESC = record
C                   NODE: integer (* +ve => index into PUNODE,
C                                    -ve => -index into EXNODE *)
C                 end;
C
C type PFPUCU = record
C                   CBNUM: integer; (* index into CBDATA *)
C                   USAGE: (readonly,update)
C               end;
 
C type PUARGDES = record
C                   TYPE: (direct,indirect);
C                   ANUM: integer;  (* argument number passed out as *)
C                   case TYPE of
C                       direct: (NODE: integer); (* PUNODE/EXNODE index *)
C                       indirect: (INUM: integer)   (* arg no. passed to *)
C                       end
C                 end;
 
C type PFPROC = record
C                   NODE: integer;  (* PUNODE/EXNODE index of associated pu *)
C                   ASSOC: integer; (* ditto of associating pu. *)
C                   STMTNO: integer (* statement number of association *)
C               end;
 
C
C type PARENT = record (* routine parent *)
C                   NODE: integer   (* PUNODE index of parent routine *)
C               end;
C
C type APARENT = record (* argument parent *)
C                   NODE: integer;  (* PUNODE index of parent routine *)
C                   ANUM: integer   (* argument number passed down *)
C                end;
 
C type PFUS = record (* unsafe reference check record *)
C               TYPE: 1..5;      (* unsafe reference type *)
C               ASSOC: integer;  (* punode index of calling p.u. *)
C               STMTNO: integer; (* statement number of reference *)
C               EXTRA: integer;  (* type-dependent extra data *)
C               CALLED: integer; (* punode/exnode index of called routine *)
C               ARGNUM: integer  (* argument number for unsafe check *)
C             end;
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C ----------------------------------------------------------------------
C
C       P F I N I T   -   Initialise PFORT-77 Common Areas
C
 
        SUBROUTINE PFINIT
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFHEAP/USHEAD,HEAP
        INTEGER USHEAD,HEAP(200000)
 
        SAVE /PFHEAP/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFNAME/NAMTXT
        COMMON/PFNAMI/NNAMES,NAMEPU
        CHARACTER*6 NAMTXT(800)
        INTEGER NNAMES,NAMEPU(800)
        SAVE /PFNAME/,/PFNAMI/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFPU/ NPUS,MAINND,PUNODE
        INTEGER NPUS,MAINND,PUNODE(500)
        SAVE /PFPU/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFCB/NCB,CBDATA
        INTEGER NCB,CBDATA(6,250)
        SAVE /PFCB/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFEXTS/NEXTS,EXNODE
        INTEGER NEXTS,EXNODE(500)
        SAVE /PFEXTS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFWMRK/NPU,NEX
        INTEGER NPU,NEX
        SAVE /PFWMRK/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFERRC/NPFERR,NPFWRN
        INTEGER NPFERR,NPFWRN
        SAVE/PFERRC/
 
        INTEGER LLCRHE
        EXTERNAL HINIT,LLCRHE
 
C Initialise /PFHEAP/
        CALL HINIT(HEAP,200000)
        USHEAD=LLCRHE(HEAP,0)
C Initialise /PFNAMI/
        NNAMES=0
C Initialise /PFPU/
        NPUS=0
C Initialise /PFCB/
        NCB=0
C Initialise /PFEXTS/
        NEXTS=0
C Initialise /PFWMRK/
        NPU=0
        NEX=0
C Initialise /PFERRC/
        NPFERR=0
        NPFWRN=0
 
        END
C ----------------------------------------------------------------------
C
C       P F C H K L   -   Perform local checks
C                         (parse tree and symbol table)
C
 
        SUBROUTINE PFCHKL(NERROR,NWARN)
        INTEGER NERROR,NWARN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/PFERRC/NPFERR,NPFWRN
        INTEGER NPFERR,NPFWRN
        SAVE/PFERRC/
 
        CALL PFTREE
        CALL PFSYCK
 
        NERROR=NPFERR
        NWARN=NPFWRN
 
        END
C ----------------------------------------------------------------------
C
C       P F T R E E   -   Check parse tree
C
 
        SUBROUTINE PFTREE
 
        INTEGER PUPTR,PUSYM,PUNUM
 
        INTEGER ZYROOT,ZYDOWN,ZYNEXT,ZYGPUS
        EXTERNAL ZYROOT,ZYDOWN,ZYNEXT,ZYGPUS
 
        PUPTR=ZYDOWN(ZYROOT())
        PUNUM=1
 
 100    PUSYM=ZYGPUS(PUNUM)
        CALL PFPUCK(PUPTR,PUSYM)
        PUPTR=ZYNEXT(PUPTR)
        PUNUM=PUNUM+1
        IF (PUPTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F S Y C K   -   Symbol table check
C
 
        SUBROUTINE PFSYCK
 
        INTEGER SYMBOL(8),SYMPTR,COMPTR,VARPTR,DTYPE,
     +          TEXT(134),BLNKCM(8),MAINPR(6)
        LOGICAL LEGAL,LOCLEG
 
        INTEGER ZYGNSY,ZIAND,ZYXGVA,ZYFDUP,EQUAL
        EXTERNAL ZYGNSY,ZIAND,ZYXGVA,ZYXGCV,ZYGTSY,ZYFDUP,
     +           ZYGTST,ZLEGAL,EQUAL
 
        DATA BLNKCM/36,67,79,77,77,79,78,129/,
     +       MAINPR/36,77,65,73,78,129/
 
        SYMPTR=0
 
 100    IF (ZYGNSY(SYMPTR,SYMBOL).NE.-100) THEN
            IF (SYMBOL(1).NE.1) THEN
                CALL ZYGTST(SYMBOL(2),TEXT)
                CALL ZLEGAL(TEXT,LEGAL,LOCLEG)
                IF (.NOT.LEGAL)
     +              LEGAL=EQUAL(TEXT,BLNKCM).EQ.-2 .OR.
     +                    EQUAL(TEXT,MAINPR).EQ.-2
                IF (.NOT.LEGAL)
     +              CALL PFERR('E: Illegal name in $P - $S',
     +                         SYMBOL(3),SYMPTR,0,0)
            END IF
            IF (SYMBOL(1).GE.3) THEN
                IF (SYMBOL(4).EQ.6) THEN
                    IF (SYMBOL(5).GT.255) THEN
                        CALL PFERR(
     +'E: Character variable $S too long in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    ELSE IF (SYMBOL(5).LT.0) THEN
                        IF (ZYXGVA(-SYMBOL(5)).GT.255)
     +                      CALL PFERR(
     +'E: Character variable $S too long in $P',SYMPTR,
     +SYMBOL(3),0,0)
                    END IF
                ELSE IF (SYMBOL(5).NE.0) THEN
                    CALL PFERR('E: Invalid data type for $S in $P',
     +                         SYMPTR,SYMBOL(3),0,0)
                ELSE IF (SYMBOL(4).EQ.7) THEN
                    CALL PFERR('E: $S is DOUBLE COMPLEX in $P',
     +                         SYMPTR,SYMBOL(3),0,0)
                END IF
                IF (ZIAND(SYMBOL(6),
     +                    2048+4096+2).EQ.
     +              2048+4096) THEN
                    CALL PFERR('E: Intrinsic $S passed as arg but n'//
     +                         'ot declared as INTRINSIC in $P',
     +                         SYMPTR,SYMBOL(3),0,0)
                ELSE IF (ZIAND(SYMBOL(6),
     +                         4096+8).EQ.
     +                         4096+8) THEN
                    CALL PFERR(
     +'E: Standard intrinsic $S explicitly typed in $P',
     +                         SYMPTR,SYMBOL(3),0,0)
                ELSE IF (SYMBOL(1).EQ.7 .AND.
     +                   ZIAND(SYMBOL(6),4096+
     +                                             2+
     +                                             1).EQ.0)
     +          THEN
                    CALL PFERR('W: External reference $S n'//
     +                         'ot declared as EXTERNAL in $P',
     +                         SYMPTR,SYMBOL(3),0,0)
                ELSE IF (SYMBOL(1).EQ.7 .AND.
     +                   SYMBOL(4).NE.-1 .AND.
     +                   ZIAND(SYMBOL(6),8+
     +                                             2+
     +                                             4096).EQ.0)
     +          THEN
                    CALL PFERR(
     +'E: External function $S implicitly typed in $P',
     +                         SYMPTR,SYMBOL(3),0,0)
                ELSE IF (ZIAND(SYMBOL(6),65536).NE.0)
     +          THEN
                    IF (SYMBOL(4).NE.1)
     +                  CALL PFERR('E: DO-loop index $S n'//
     +                             'ot INTEGER in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    IF (SYMBOL(1).EQ.4)
     +                  CALL PFERR('E: Program-unit name $S used as '//
     +                             'DO loop index',SYMPTR,0,0,0)
                END IF
                IF (ZIAND(SYMBOL(6),4).NE.0) THEN
                    IF (ZIAND(SYMBOL(6),16).NE.0) THEN
                        CALL PFERR(
     +'E: Dummy argument $S used in ASSIGN in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    ELSE IF (ZIAND(SYMBOL(6),256).NE.0)
     +              THEN
                        CALL PFERR(
     +'E: Dummy argument $S is a statement function dummy in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    END IF
                ELSE IF (ZIAND(SYMBOL(6),256).NE.0)
     +          THEN
                    IF (ZIAND(SYMBOL(6),16).NE.0)
     +                  CALL PFERR(
     +'E: Stmt fn dummy argument $S used in ASSIGN in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                END IF
                IF (ZIAND(SYMBOL(6),1048576).NE.0) THEN
                    IF (ZIAND(SYMBOL(6),
     +                        32+64+16).NE.0)
     +                  CALL PFERR(
     +'W: $S is used in an array declarator but is updated in $P',
     +                      SYMPTR,SYMBOL(3),0,0)
                END IF
                CALL PFCHKU(SYMBOL,SYMPTR)
            ELSE IF (SYMBOL(1).EQ.2) THEN
                COMPTR=SYMPTR
                DTYPE=4
 200            CALL ZYXGCV(COMPTR,VARPTR)
                CALL ZYGTSY(VARPTR,SYMBOL)
                IF ((SYMBOL(4).EQ.4 .OR.
     +              SYMBOL(4).EQ.5) .AND.
     +              DTYPE.NE.4 .AND. DTYPE.NE.5)
     +          THEN
                    CALL PFERR(
     +'E: COMPLEX o'//'r DOUBLE PRECISION n'//'ot first in COMMON /'//
     +'$S/ in $P',SYMPTR,SYMBOL(3),0,0)
                    GOTO 100
                END IF
                DTYPE=SYMBOL(4)
                IF (COMPTR.NE.0) GOTO 200
                VARPTR=ZYFDUP(SYMPTR)
                IF (VARPTR.GT.0) THEN
                    CALL ZYGTSY(VARPTR,SYMBOL)
                    IF (SYMBOL(1).EQ.8) THEN
                        CALL PFERR(
     +'E: $S names both COMMON a'//'nd a statement function in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    ELSE IF (SYMBOL(1).EQ.6) THEN
                        CALL PFERR(
     +'E: $S names both COMMON a'//'nd a PARAMETER in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    ELSE IF (ZIAND(SYMBOL(6),16).NE.0)
     +              THEN
                        CALL PFERR(
     +'E: $S names both COMMON a'//'nd an ASSIGN variable in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    ELSE IF (ZIAND(SYMBOL(6),4).NE.0)
     +              THEN
                        CALL PFERR(
     +'E: $S names both COMMON a'//'nd a dummy argument in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    ELSE IF (ZIAND(SYMBOL(6),256).NE.0)
     +              THEN
                        CALL PFERR(
     +'E: $S names both COMMON a'//'nd a stmt fn dummy in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    END IF
                END IF
            END IF
            GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F C H K U   -   Check symbol usage
C
 
        SUBROUTINE PFCHKU(SYMBOL,SYMPTR)
        INTEGER SYMBOL(8),SYMPTR
 
        INTEGER SET,REF,NONLOC
        PARAMETER (SET=16+32+64+128+
     +                 65536+131072)
        PARAMETER (REF=2048+16384+65536)
        PARAMETER (NONLOC=4+256+1024+
     +                    524288)
 
        INTEGER PTR,RESULT(8),VARPTR,EQHCOM,EQHUSE,EQVPTR,TMP
 
        INTEGER ZIAND,ZYGNSW,ZIOR
        LOGICAL ZYXVOL
        EXTERNAL ZIAND,ZYGNSW,ZYXGEH,ZYGTSY,ZYXVOL,ZIOR
 
        IF (SYMBOL(1).EQ.3) THEN
            IF (ZIAND(SYMBOL(6),4).NE.0) THEN
                CALL PFERR('W: Unused dummy argument: $S in $P',
     +                     SYMPTR,SYMBOL(3),0,0)
            ELSE
                CALL PFERR('W: Unused symbol: $S in $P',
     +                     SYMPTR,SYMBOL(3),0,0)
            END IF
        ELSE IF (SYMBOL(1).EQ.5 .AND.
     +           ZIAND(SYMBOL(6),NONLOC).EQ.0) THEN
            IF (ZIAND(SYMBOL(6),125936).EQ.0) THEN
                CALL PFERR('W: Unused variable: $S in $P',
     +                     SYMPTR,SYMBOL(3),0,0)
            ELSE IF (ZIAND(SYMBOL(6),SET).EQ.0 .NEQV.
     +               ZIAND(SYMBOL(6),REF).EQ.0) THEN
                IF (ZIAND(SYMBOL(6),512).NE.0) THEN
                    IF (SYMBOL(4).EQ.4)
     +                  SYMBOL(4)=2
                    IF (SYMBOL(4).EQ.7)
     +                  SYMBOL(4)=5
                    CALL ZYXGEH(SYMPTR,EQHCOM,EQHUSE,EQVPTR)
  50                CALL ZYXGED(EQVPTR,VARPTR,TMP)
                    IF (SYMPTR.NE.VARPTR .AND.
     +                  ZYXVOL(SYMPTR,VARPTR)) THEN
                        CALL ZYGTSY(VARPTR,RESULT)
                        IF (SYMBOL(4).EQ.RESULT(4)
     +                      .OR. RESULT(4).EQ.4
     +                      .AND. SYMBOL(4).EQ.2
     +                      .OR. RESULT(4).EQ.7
     +                      .AND. SYMBOL(4).EQ.5)
     +                      SYMBOL(6)=
     +                          ZIOR(SYMBOL(6),
     +                               RESULT(6))
                    END IF
                    IF (EQVPTR.NE.0) GOTO 50
                END IF
                IF (ZIAND(SYMBOL(6),SET).EQ.0 .NEQV.
     +              ZIAND(SYMBOL(6),REF).EQ.0) THEN
                    IF (ZIAND(SYMBOL(6),SET).EQ.0) THEN
                        CALL PFERR(
     +'E: Variable referenced but n'//'ot set - $S in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    ELSE
                        CALL PFERR(
     +'W: Variable set but n'//'ot referenced - $S in $P',
     +                             SYMPTR,SYMBOL(3),0,0)
                    END IF
                END IF
            END IF
        ELSE IF (SYMBOL(1).EQ.4 .AND.
     +           SYMBOL(4).GT.0 .AND.
     +           ZIAND(SYMBOL(6),SET).EQ.0) THEN
            PTR=SYMPTR
 100        IF (ZYGNSW(PTR,SYMBOL(3),RESULT).EQ.-2) THEN
                IF (RESULT(1).NE.9) THEN
                    GOTO 100
                ELSE IF (ZIAND(RESULT(6),SET).EQ.0) THEN
                    GOTO 100
                END IF
            ELSE
                CALL PFERR('E: Function value n'//'ot set - $S',
     +                     SYMPTR,0,0,0)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F P U C K   -   Check a program-unit's parse tree
C
 
        SUBROUTINE PFPUCK(PUROOT,PUSYM)
        INTEGER PUROOT,PUSYM
 
        INTEGER SPTR,STMTNO
 
        INTEGER ZYDOWN,ZYNEXT
        EXTERNAL ZYDOWN,ZYNEXT
 
        SPTR=ZYDOWN(PUROOT)
        STMTNO=1
 
 100    CALL PFSTCK(SPTR,STMTNO,PUSYM)
        SPTR=ZYNEXT(SPTR)
        STMTNO=STMTNO+1
        IF (SPTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P F S T C K   -   Check the parse tree of a statement
C
 
        SUBROUTINE PFSTCK(SPTR,STMTNO,PUSYM)
        INTEGER SPTR,STMTNO,PUSYM
 
        INTEGER PTR,NEXT,STYPE,DOVAR
 
        INTEGER ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXGTB,ZIAND
        EXTERNAL ZYDOWN,ZYNEXT,ZYUP,ZYNTYP,ZYXGTB,ZIAND
 
        STYPE=ZYNTYP(SPTR)
        IF (STYPE.EQ.64) THEN
            CALL PFERR('E: PAUSE statement found, statement $I in $S',
     +                 STMTNO,PUSYM,0,0)
        ELSE IF (STYPE.EQ.75) THEN
            CALL PFERR(
     +'W: The BACKSPACE statement is non-portable, statement $I in $S',
     +                 STMTNO,PUSYM,0,0)
        ELSE IF (STYPE.EQ.76) THEN
            CALL PFERR(
     +'W: The ENDFILE statement is non-portable, statement $I in $S',
     +                 STMTNO,PUSYM,0,0)
        ELSE IF (STYPE.EQ.61) THEN
            DOVAR=0
        ELSE IF (STYPE.EQ.41) THEN
            IF (ZIAND(ZYXGTB(SPTR),16777216).NE.0)
     +          CALL PFERR(
     +'E: Type conversion in DATA at statement $I in $S',
     +                     STMTNO,PUSYM,0,0)
        END IF
        PTR=ZYDOWN(SPTR)
        IF (PTR.EQ.0) RETURN
 
 100    CONTINUE
C Visit node PTR
        CALL PFVNOD(PTR,STYPE,STMTNO,PUSYM,DOVAR)
C Go down from PTR
        NEXT=ZYDOWN(PTR)
        IF (NEXT.GT.0) THEN
            PTR=NEXT
            GOTO 100
        END IF
C At a leaf - go next
 200    NEXT=ZYNEXT(PTR)
        IF (NEXT.EQ.0) THEN
            PTR=ZYUP(PTR)
            IF (PTR.NE.SPTR) GOTO 200
        END IF
        IF (NEXT.NE.0) THEN
            PTR=NEXT
            GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P F V N O D   -   Visit a node in the parse tree
C
 
        SUBROUTINE PFVNOD(NODE,STYPE,STMTNO,PUSYM,DOVAR)
        INTEGER NODE,STYPE,STMTNO,PUSYM,DOVAR
 
        INTEGER MAXCSW
        PARAMETER (MAXCSW=10)
 
        INTEGER NTYPE,TEXT(134),I,PTR,SYMBOL(8),DTYPE,NCSW
        CHARACTER C
        LOGICAL WARNED,MIXEDT
 
        CHARACTER ZCITOC
        INTEGER ZYNTYP,ZYDOWN,ZYXGDT,ZYXGVA,ZYNEXT,ZYXEAE,
     +          ZYUP,ZIAND,ZYXGTB
        EXTERNAL ZYNTYP,ZYDOWN,ZYXGDT,ZYXGVA,ZYGTST,ZCITOC,ZYNEXT,
     +           ZYUP,ZYGTSY,ZYXEAE,ZIAND,ZYXGTB,ZYSABT
 
        DATA NCSW/0/
 
        NTYPE=ZYNTYP(NODE)
        IF (NTYPE.EQ.113 .AND. STYPE.NE.78) THEN
            CALL PFERR(
     +          'E: Hollerith constant found at statement $I in $S',
     +          STMTNO,PUSYM,0,0)
 
        ELSE IF (NTYPE.EQ.102) THEN
            IF (ZYXGDT(NODE).EQ.7)
     +          CALL PFERR(
     +'E: Double Complex constant found at statement $I in $S',
     +                     STMTNO,PUSYM,0,0)
 
        ELSE IF (NTYPE.EQ.114 .OR. NTYPE.EQ.113) THEN
            IF (ZYXGVA(NODE).GT.64) THEN
                CALL PFERR(
     +'E: Character constant too long at statement $I in $S',
     +                     STMTNO,PUSYM,0,0)
            ELSE IF (NCSW.LT.MAXCSW) THEN
                CALL ZYGTST(-ZYDOWN(NODE),TEXT)
                WARNED=.FALSE.
                DO 100 I=1,ZYXGVA(NODE)
                    IF (TEXT(I).EQ.36 .AND..NOT.WARNED) THEN
                        NCSW=NCSW+1
                        CALL PFERR(
     +'W: Currency symbol in character constant at statement $I in $S',
     +                             STMTNO,PUSYM,0,0)
                        IF (NCSW.EQ.MAXCSW) THEN
                            CALL PFERR(
     +'W: Further character set warnings will be suppressed',
     +                                 0,0,0,0)
                            RETURN
                        END IF
                        WARNED=.TRUE.
                    ELSE IF (INDEX(
     +' ETOANIRSHBCDFGJKLMPQUVWXYZ0123456789*()-=+'':/.,$',
     +                        ZCITOC(TEXT(I),C)).EQ.0) THEN
                        NCSW=NCSW+1
                        CALL PFERR('W: Non-standard character '''//C//
     +''' in character constant at statement $I in $S',
     +                             STMTNO,PUSYM,0,0)
                        IF (NCSW.EQ.MAXCSW) CALL PFERR(
     +'W: Further character set warnings will be suppressed',
     +                                                 0,0,0,0)
                        RETURN
                    END IF
 100            CONTINUE
            END IF
        ELSE IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
     +           NTYPE.EQ.98 .OR. NTYPE.EQ.99 .OR.
     +           NTYPE.EQ.100) THEN
            IF (ZYXGDT(NODE).EQ.7) CALL PFERR(
     +'E: Double complex operation at statement $I in $S',
     +          STMTNO,PUSYM,0,0)
        ELSE IF (NTYPE.EQ.112) THEN
            CALL ZYGTST(-ZYDOWN(NODE),TEXT)
            IF ((TEXT(1).EQ.84 .OR. TEXT(1).EQ.116) .AND.
     +          (TEXT(2).EQ.76 .OR. TEXT(2).EQ.108 .OR.
     +          TEXT(2).GE.48 .AND. TEXT(2).LE.57))
     +          CALL PFERR(
     +'E: T o'//'r TL edit descriptor at statement $I in $S',
     +                     STMTNO,PUSYM,0,0)
        ELSE IF (NTYPE.EQ.54 .AND. STYPE.EQ.53) THEN
            CALL PFERR(
     +'E: Label list supplied in assigned GOTO at statement $I in $S',
     +                 STMTNO,PUSYM,0,0)
        ELSE IF (NTYPE.EQ.108 .AND. STYPE.EQ.61) THEN
            IF (DOVAR.EQ.0) THEN
                IF (ZYNTYP(ZYUP(NODE)).NE.48 .OR.
     +              ZYDOWN(ZYUP(NODE)).NE.NODE) THEN
                    CALL PFERR(
     +'I: Apparently badly formed DOSPEC subtree at node $I',
     +                         NODE,0,0,0)
                ELSE
                    DOVAR=ZYDOWN(NODE)
                END IF
            ELSE IF (ZYDOWN(NODE).EQ.DOVAR) THEN
                IF (ZYNTYP(ZYUP(NODE)).NE.48 .OR.
     +              ZYDOWN(ZYUP(NODE)).NE.NODE)
     +              CALL PFERR(
     +'E: DO variable used in limit expression at statement $I in $S',
     +                         STMTNO,PUSYM,0,0)
            END IF
        ELSE IF (NTYPE.EQ.108 .AND. STYPE.EQ.30) THEN
            NTYPE=ZYNTYP(ZYUP(NODE))
            IF (NTYPE.EQ.30 .OR. NTYPE.EQ.31) THEN
                CALL ZYSABT(-ZYDOWN(NODE),6,4194304)
            ELSE
                CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
                IF (SYMBOL(7).EQ.0 .AND.
     +              ZIAND(SYMBOL(6),
     +                    4194304+8).EQ.8)
     +              CALL PFERR(
     +'E: $S used in array declarator before type declaration, at '//
     +'statement $I in $S',-ZYDOWN(NODE),STMTNO,PUSYM,0)
            END IF
        ELSE IF (NTYPE.EQ.25) THEN
            PTR=ZYDOWN(NODE)
            MIXEDT=.FALSE.
            DTYPE=ZYXGDT(PTR)
 200        PTR=ZYNEXT(PTR)
            IF (PTR.NE.0) THEN
                IF (ZYXGDT(PTR).EQ.DTYPE) GOTO 200
                MIXEDT=.TRUE.
            END IF
            IF (MIXEDT) THEN
                PTR=ZYDOWN(NODE)
 300            NTYPE=ZYNTYP(PTR)
                IF (NTYPE.EQ.104) THEN
                    IF (ZYXEAE(PTR).NE.0) THEN
                        CALL PFERR(
     +'E: Equivalence of non-initial array element involving differin'//
     +'g data types',0,0,0,0)
                        CALL PFERR(
     +' array $S at statement $I in $S',-ZYDOWN(ZYDOWN(PTR)),
     +                             STMTNO,PUSYM,0)
                    END IF
                ELSE IF (NTYPE.EQ.103) THEN
                    I=ZYDOWN(PTR)
                    IF (ZYNTYP(I).EQ.104) THEN
                        IF (ZYXEAE(I).NE.0) THEN
                            CALL PFERR(
     +'E: Equivalence of non-initial array element involving differin'//
     +'g data types',0,0,0,0)
                            CALL PFERR(
     +' array $S at statement $I in $S',-ZYDOWN(ZYDOWN(I)),
     +                             STMTNO,PUSYM,0)
                        END IF
                    END IF
                END IF
                PTR=ZYNEXT(PTR)
                IF (PTR.NE.0) GOTO 300
            END IF
        ELSE IF (NTYPE.EQ.89 .OR. NTYPE.EQ.90 .OR.
     +           NTYPE.EQ.93 .OR. NTYPE.EQ.94) THEN
            IF (ZYXGDT(ZYDOWN(NODE)).EQ.6)
     +          CALL PFERR(
     +'E: Relational operator used with character operands at '//
     +                     'statement $I in $S',STMTNO,PUSYM,0,0)
        ELSE IF (NTYPE.EQ.123) THEN
            PTR=ZYDOWN(NODE)
            IF (ZIAND(ZYXGTB(PTR),4194304).NE.0) THEN
                IF (ZYXGDT(PTR).NE.6)
     +              CALL PFERR(
     +'E: Invalid type of array used for format-identifier at '//
     +                         'statement $I in $S',STMTNO,PUSYM,0,0)
            END IF
        END IF
 
        END
